* Пример простейшей оболочки экспертной системы
* Используется метод обратного вывода
* Программа КОНЦЕПТ, 17.10.2010, www.gendoc.ru
* 02.11.2010 - добавлено правило 14 про корову (парнокопытное и имеет рога)

*** Начало программы

Создать_базу_знаний
выбрать (ввести меню1 $результат 'Выберите действие:' 'Показать базу знаний;Интерпретировать базу знаний;Выход' )
  вариант 'Показать базу знаний'
    Показать_базу_знаний
  вариант 'Интерпретировать базу знаний'
    Интерпретировать_базу_знаний
конецВыбора

*** Функции

функция Интерпретировать_базу_знаний
память локальный гипотеза решение_найдено

  показать сообщение 'Загадайте животное и откровенно отвечайте на вопросы.'
  Протокол 'Протокол логического вывода.'

  Подготовка_к_логическому_выводу
  присвоить решение_найдено [$ложь]

  для [ТЕРМИНАЛЬНЫЕ_СЛЕДСТВИЯ]
    присвоить гипотеза [$объектЦикла]
    если (Доказать_гипотезу [гипотеза] 0 )
      присвоить решение_найдено [$истина]
      присвоить $списокЦикла {} 
    конец
  следующий

  если [решение_найдено]
    показать сообщение "Это [гипотеза]!" 
  иначе
    показать сообщение 'Решение не найдено.'
  конец

  Протокол '' 
  Протокол "Отработавшие правила: [ОТРАБОТАВШИЕ_ПРАВИЛА]"
*  отладка
возврат

функция Подготовка_к_логическому_выводу
  список кМножеству ВСЕ_СЛЕДСТВИЯ (факт домен $результат правило <следствие> )
  список кМножеству ВСЕ_УСЛОВИЯ (список терминальные $результат (факт домен $результат правило <условие> ) )
  множество разность ТЕРМИНАЛЬНЫЕ_СЛЕДСТВИЯ [ВСЕ_СЛЕДСТВИЯ] [ВСЕ_УСЛОВИЯ]
  множество разность ТЕРМИНАЛЬНЫЕ_УСЛОВИЯ [ВСЕ_УСЛОВИЯ] [ВСЕ_СЛЕДСТВИЯ]
  факт сопоставить ВСЕ_ПРАВИЛА r;правило;[?];[?]
  присвоить ОТРАБОТАВШИЕ_ПРАВИЛА {}
возврат

функция Доказать_И гипотезы глубина
  память локальный доказано подцель

  присвоить доказано [$истина]
  для [гипотезы]
    присвоить подцель [$объектЦикла]
    присвоить доказано (Доказать_гипотезу [подцель] [глубина] )
    если [доказано]
    иначе
      присвоить $списокЦикла {}
    конец
  следующий

  присвоить $результат [доказано]
возврат

функция Доказать_ИЛИ гипотеза глубина
  память локальный доказано правила список_подцелей

  присвоить доказано [$ложь]
  факт сопоставить правила "r;правило;[гипотеза];[?]"
  для [правила]
    Протокол "    Применение Правила N [$объектЦикла] для '[гипотеза]'"
    список взять список_подцелей (факт взять $результат [$объектЦикла] ) 4
    присвоить доказано (Доказать_И [список_подцелей] [глубина] )
    если [доказано]
      список сцепить ОТРАБОТАВШИЕ_ПРАВИЛА [ОТРАБОТАВШИЕ_ПРАВИЛА] [$объектЦикла]
      присвоить $списокЦикла {}
    конец
  следующий

  присвоить $результат [доказано]
возврат 

функция Доказать_гипотезу гипотеза глубина
  память локальный доказано правила

  увеличить глубина
  если [глубина] = 1
    Протокол ''
    Протокол "([глубина]) ГИПОТЕЗА: [гипотеза]"
  иначе
    Протокол "([глубина]) ПОДЦЕЛЬ: [гипотеза]"
  конец

  присвоить доказано [$ложь]

* 1) Промежуточная гипотеза может быть уже доказана
  если (память существует $результат "УСТАНОВЛЕНО;[гипотеза]" )
    если [УСТАНОВЛЕНО;[гипотеза]] == да
      присвоить доказано [$истина]
    конец
  иначе
* 2) Гипотеза может быть безусловно истинной
    факт сопоставить правила "r;правило;[гипотеза];{}"
    если [правила]
      присвоить доказано [$истина]
    конец
* 3) Может потребоваться запросить пользователя
  если (множество и $результат [ТЕРМИНАЛЬНЫЕ_УСЛОВИЯ] [гипотеза] )
    присвоить доказано (Запросить_пользователя [гипотеза] )
  иначе
* 4) Поиск и применение правил, в которых гипотеза является следствием
    присвоить доказано (Доказать_ИЛИ [гипотеза] [глубина] )
  конец
  конец
  конец

  если [доказано]
    присвоить "УСТАНОВЛЕНО;[гипотеза]" да    
  конец

  Протокол "([глубина]) [гипотеза] ===> [доказано]"
  присвоить $результат [доказано]
возврат

функция Запросить_пользователя гипотеза
  память локальный ответ_пользователя 

  множество разность ТЕРМИНАЛЬНЫЕ_УСЛОВИЯ [ТЕРМИНАЛЬНЫЕ_УСЛОВИЯ] [гипотеза]
  ввести меню1 ответ_пользователя "[гипотеза]?" 'да;нет;не знаю'
  если [ответ_пользователя] == ''
    присвоить ответ_пользователя 'не знаю'
  конец
  Протокол "    ВОПРОС: [гипотеза]? [ответ_пользователя]"
  если [ответ_пользователя] == да
    присвоить $результат [$истина]
  иначе
    присвоить $результат [$ложь]
  конец     
возврат

функция Создать_базу_знаний
* Пример из книги: К.Таунсенд, Д.Фохт. "Проектирование и программная реализация экспертных систем
* на персональных ЭВМ". Москва, Финансы и статистика, 1990. Стр.76. 

факт добавить \
's;правило;<следствие>;<условие>' \
'r;правило;млекопитающее;имеет волосяной покров' \
'r;правило;млекопитающее;дает молоко' \
'r;правило;птица;имеет перья' \
'r;правило;птица;{может летать;откладывает яйца}' \
'r;правило;хищник;ест мясо' \
'r;правило;хищник;{имеет острые зубы;имеет когти;его глаза смотрят вперед}' \
'r;правило;парнокопытное;{млекопитающее;имеет копыта}' \
'r;правило;парнокопытное;{млекопитающее;жует жвачку}' \
'r;правило;гепард;{млекопитающее;хищник;окраска желто-коричневая;имеет на коже черные пятна}' \
'r;правило;тигр;{млекопитающее;хищник;окраска желто-коричневая;имеет на коже темные полосы}' \
'r;правило;жираф;{парнокопытное;шея длинная;ноги длинные;имеет на коже черные пятна}' \
'r;правило;зебра;{парнокопытное;имеет на коже черные полосы}' \
'r;правило;корова;{парнокопытное;имеет рога}' \
'r;правило;страус;{птица;не может летать;шея длинная;ноги длинные;окраска черно-белая}' \
'r;правило;пингвин;{птица;не может летать;может плавать;окраска черно-белая}' \
'r;правило;альбатрос;{птица;хорошо летает}' 
*'r;правило;откладывает яйца;{}'
возврат

функция Протокол текст
  >[текст]
возврат

функция Показать_базу_знаний
  память локальный номер_факта
  печать '' 'База знаний.' ========= ''
  присвоить номер_факта 1
  пока [номер_факта] <= [$количествоФактов]
    Показать_правило [номер_факта]
    увеличить номер_факта
  цикл
возврат

функция Показать_правило номер
  память локальный успешно условие следствие условие_текст

  список сопоставить успешно (факт взять $результат [номер] ) r;правило;[?следствие];[?условие]
  если [успешно]
    присвоить условие_текст ''
    для [условие]
      если [условие_текст]  == ''
        присвоить условие_текст [$объектЦикла]
      иначе
        присвоить условие_текст "[условие_текст] И [$объектЦикла]"
      конец
    следующий

    печать "Правило N [номер]."
    если [условие] != {}
      печать "ЕСЛИ [условие_текст]," "  ТО [следствие]."
    иначе
      печать "ИЗВЕСТНО, ЧТО [следствие]."
    конец
    печать ''
  конец
возврат